Visual Basic Graphics Programming (2nd Edition)/Visual Basic Graphics Programming 2nd Edition.iso/OldSrc/CH3/SRC/PALDRAW.FRM

Text File | 1996-05-01 | 14KB | 510 lines

VERSION 4.00
Begin VB.Form PalDrawForm
   Caption         =   "PalDraw"
   ClientHeight    =   4260
   ClientLeft      =   1455
   ClientTop       =   1440
   ClientWidth     =   7200
   DrawMode        =   14  'Copy Pen
   Height          =   4950
   Left            =   1395
   LinkTopic       =   "Form1"
   ScaleHeight     =   4260
   ScaleWidth      =   7200
   Top             =   810
   Width           =   7320
   Begin VB.PictureBox ForeColorSwatch
      AutoRedraw      =   -1  'True
      Height          =   500
      Left            =   840
      ScaleHeight     =   435
      ScaleWidth      =   435
      TabIndex        =   12
      Top             =   1440
      Width           =   500
   End
   Begin VB.PictureBox FillColorSwatch
      AutoRedraw      =   -1  'True
      Height          =   500
      Left            =   840
      ScaleHeight     =   435
      ScaleWidth      =   435
      TabIndex        =   9
      Top             =   2040
      Width           =   500
   End
   Begin VB.ComboBox FillCombo
      Height          =   315
      ItemData        =   "PALDRAW.frx":0000
      Left            =   840
      List            =   "PALDRAW.frx":001C
      Style           =   2  'Dropdown List
      TabIndex        =   8
      Top             =   1080
      Width           =   1815
   End
   Begin VB.ComboBox DrawCombo
      Height          =   315
      ItemData        =   "PALDRAW.frx":008F
      Left            =   840
      List            =   "PALDRAW.frx":00A8
      Style           =   2  'Dropdown List
      TabIndex        =   6
      Top             =   720
      Width           =   1815
   End
   Begin VB.ComboBox ObjectCombo
      Height          =   315
      ItemData        =   "PALDRAW.frx":00E7
      Left            =   840
      List            =   "PALDRAW.frx":00F7
      Style           =   2  'Dropdown List
      TabIndex        =   3
      Top             =   0
      Width           =   1815
   End
   Begin VB.TextBox WidthText
      Height          =   285
      Left            =   840
      MaxLength       =   1
      TabIndex        =   2
      Text            =   "1"
      Top             =   360
      Width           =   375
   End
   Begin VB.PictureBox Canvas
      AutoRedraw      =   -1  'True
      Height          =   4238
      Left            =   2700
      ScaleHeight     =   4185
      ScaleWidth      =   4440
      TabIndex        =   0
      Top             =   0
      Width           =   4500
   End
   Begin VB.Label Label1
      Caption         =   "FillColor"
      Height          =   255
      Index           =   5
      Left            =   0
      TabIndex        =   11
      Top             =   2160
      Width           =   855
   End
   Begin VB.Label Label1
      Caption         =   "ForeColor"
      Height          =   255
      Index           =   4
      Left            =   0
      TabIndex        =   10
      Top             =   1560
      Width           =   855
   End
   Begin MSComDlg.CommonDialog FileDialog
      Left            =   1560
      Top             =   1560
      _version        =   65536
      _extentx        =   847
      _extenty        =   847
      _stockprops     =   0
      cancelerror     =   -1  'True
   End
   Begin VB.Label Label1
      Caption         =   "FillStyle"
      Height          =   255
      Index           =   3
      Left            =   0
      TabIndex        =   7
      Top             =   1080
      Width           =   855
   End
   Begin VB.Label Label1
      Caption         =   "DrawStyle"
      Height          =   255
      Index           =   2
      Left            =   0
      TabIndex        =   5
      Top             =   720
      Width           =   855
   End
   Begin VB.Label Label1
      Caption         =   "DrawWidth"
      Height          =   255
      Index           =   1
      Left            =   0
      TabIndex        =   4
      Top             =   360
      Width           =   855
   End
   Begin VB.Label Label1
      Caption         =   "Object"
      Height          =   255
      Index           =   0
      Left            =   0
      TabIndex        =   1
      Top             =   0
      Width           =   855
   End
   Begin VB.Menu mnuFile
      Caption         =   "&File"
      Begin VB.Menu mnuFileLoad
         Caption         =   "&Load..."
         Shortcut        =   ^L
      End
      Begin VB.Menu mnuFileSep
         Caption         =   "-"
      End
      Begin VB.Menu mnuFileExit
         Caption         =   "E&xit"
      End
   End
End
Attribute VB_Name = "PalDrawForm"
Attribute VB_Creatable = False
Attribute VB_Exposed = False
Option Explicit

Const OBJ_LINE = 0
Const OBJ_BOX = 1
Const OBJ_CIRCLE = 2
Const OBJ_POINT = 3

Dim Obj As Integer  ' The kind of object to draw.

Dim Rubberbanding As Boolean
Dim oldmode As Integer
Dim OldStyle As Integer
Dim FirstX As Single
Dim FirstY As Single
Dim LastX As Single
Dim LastY As Single

Dim SWid As Single
Dim SHgt As Single
' ***********************************************
' Draw the final (non-rubberband) object.
' ***********************************************
Sub DrawObject()
    ' Draw the object.
    Select Case Obj
        Case OBJ_LINE
            Canvas.Line (FirstX, FirstY)-(LastX, LastY)

        Case OBJ_BOX
            Canvas.Line (FirstX, FirstY)-(LastX, LastY), , B

        Case OBJ_CIRCLE
            Dim xmid As Single
            Dim ymid As Single
            Dim dx As Single
            Dim dy As Single
            Dim radius As Single

            xmid = (FirstX + LastX) / 2
            ymid = (FirstY + LastY) / 2
            dx = Abs(FirstX - LastX)
            dy = Abs(FirstY - LastY)
            If dx < dy Then
                radius = dx / 2
            Else
                radius = dy / 2
            End If
            Canvas.Circle (xmid, ymid), radius

        Case OBJ_POINT
            Canvas.PSet (LastX, LastY)

    End Select
End Sub

' ***********************************************
' Draw the appropriate kind of rubberband object.
' ***********************************************
Sub DrawRubberObject()
    Select Case Obj
        Case OBJ_LINE
            Canvas.Line (FirstX, FirstY)-(LastX, LastY)

        Case OBJ_BOX
            Canvas.Line (FirstX, FirstY)-(LastX, LastY), , B

        Case OBJ_CIRCLE
            Dim xmid As Single
            Dim ymid As Single
            Dim dx As Single
            Dim dy As Single
            Dim radius As Single

            xmid = (FirstX + LastX) / 2
            ymid = (FirstY + LastY) / 2
            dx = Abs(FirstX - LastX)
            dy = Abs(FirstY - LastY)
            If dx < dy Then
                radius = dx / 2
            Else
                radius = dy / 2
            End If
            Canvas.Circle (xmid, ymid), radius

        Case OBJ_POINT
            Canvas.PSet (LastX, LastY)

    End Select
End Sub





' ***********************************************
' Start a rubberbanding of some sort.
' ***********************************************
Private Sub Canvas_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    ' Let MouseMove know we are rubberbanding.
    Rubberbanding = True

    ' Save values so we can restore them later.
    oldmode = Canvas.DrawMode
    OldStyle = Canvas.DrawStyle
    Canvas.DrawMode = vbInvert
    If Obj = OBJ_LINE Then
        Canvas.DrawStyle = vbSolid
    Else
        Canvas.DrawStyle = vbDot
    End If

    ' Save the starting coordinates.
    FirstX = X
    FirstY = Y

    ' Save the ending coordinates.
    LastX = X
    LastY = Y

    ' Draw the appropriate rubberband object.
    DrawRubberObject
End Sub


' ***********************************************
' Continue rubberbanding.
' ***********************************************
Private Sub Canvas_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    ' If we are not rubberbanding, do nothing.
    If Not Rubberbanding Then Exit Sub

    ' Erase the previous rubberband object.
    DrawRubberObject

    ' Save the new ending coordinates.
    LastX = X
    LastY = Y

    ' Draw the new rubberband object.
    DrawRubberObject
End Sub

' ***********************************************
' Finish rubberbanding and draw the object.
' ***********************************************
Private Sub Canvas_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    ' If we are not rubberbanding, do nothing.
    If Not Rubberbanding Then Exit Sub

    ' We are no longer rubberbanding.
    Rubberbanding = False

    ' Erase the previous rubberband object.
    DrawRubberObject

    ' Restore the original DrawMode and DrawStyle.
    Canvas.DrawMode = oldmode
    Canvas.DrawStyle = OldStyle

    ' Draw the final object.
    DrawObject
End Sub



Private Sub DrawCombo_Click()
    Canvas.DrawStyle = DrawCombo.ListIndex
End Sub

Private Sub FillCombo_Click()
    Canvas.FillStyle = FillCombo.ListIndex
End Sub


' ***********************************************
' Allow the user to select a new foreground
' color.
' ***********************************************
Private Sub ForeColorSwatch_Click()
Dim popup As New PalettePopup
Dim clr As Long

    ' Load the picture to get its palette.
    popup.Picture = Canvas.Picture

    ' Fill the popup with palette colors.
    popup.Fill

    ' Select the current foreground color.
    popup.SelectedColor = Canvas.ForeColor

    ' Let the user select a color.
    popup.Show vbModal

    ' Set the selected color using the palete
    ' relative RGB value.
    clr = popup.SelectedColor + &H2000000
    Canvas.ForeColor = clr
    ForeColorSwatch.Line _
        (0, 0)-(SWid, SHgt), clr, BF

    Unload popup
End Sub
' ***********************************************
' Allow the user to select a new fill color.
' ***********************************************
Private Sub FillColorSwatch_Click()
Dim popup As New PalettePopup
Dim clr As Long

    ' Load the picture to get its palette.
    popup.Picture = Canvas.Picture

    ' Fill the popup with palette colors.
    popup.Fill

    ' Select the current background color.
    popup.SelectedColor = Canvas.FillColor

    ' Let the user select a color.
    popup.Show vbModal

    ' Set the selected color using the palete
    ' relative RGB value.
    clr = popup.SelectedColor + &H2000000
    Canvas.FillColor = clr
    FillColorSwatch.Line _
        (0, 0)-(SWid, SHgt), clr, BF

    Unload popup
End Sub


Private Sub Form_Load()
    ' Select the default options.
    DrawCombo.ListIndex = Canvas.DrawStyle
    FillCombo.ListIndex = Canvas.FillStyle
    ObjectCombo.ListIndex = Canvas.FillStyle
    WidthText.Text = Format$(Canvas.DrawWidth)

    SWid = ForeColorSwatch.ScaleWidth - 1
    SHgt = ForeColorSwatch.ScaleHeight - 1

    ' Fill the color swatches.
    ResetSwatches
End Sub
' ***********************************************
' Set the colors in the swatches.
' ***********************************************
Sub ResetSwatches()
Dim clr As Long

    Canvas.Refresh

    ' Make the swatches use the same logical
    ' palette as the canvas.
    ForeColorSwatch.Picture = Canvas.Picture
    FillColorSwatch.Picture = Canvas.Picture

    ' Start with black again.
    Canvas.ForeColor = vbBlack
    Canvas.FillColor = vbBlack
    ForeColorSwatch.Line (0, 0)-(SWid, SHgt), vbBlack, BF
    FillColorSwatch.Line (0, 0)-(SWid, SHgt), vbBlack, BF
End Sub

Private Sub Form_Resize()
Dim wid As Single

    wid = ScaleWidth - ObjectCombo.Left - ObjectCombo.Width - 30
    If wid < 100 Then wid = 100

    Canvas.Move ScaleWidth - wid, 0, wid, ScaleHeight
End Sub

Private Sub mnuFileExit_Click()
    Unload Me
End Sub


Private Sub mnuFileLoad_Click()
Dim fname As String

    ' Allow the user to pick a file.
    On Error Resume Next
    FileDialog.filename = "*.BMP;*.ICO;*.RLE;*.WMF;*.DIB"
    FileDialog.Flags = cdlOFNFileMustExist + cdlOFNHideReadOnly
    FileDialog.ShowOpen
    If Err.Number = cdlCancel Then
        Exit Sub
    ElseIf Err.Number <> 0 Then
        Beep
        MsgBox "Error selecting file.", , vbExclamation
        Exit Sub
    End If
    On Error GoTo LoadError

    fname = Trim$(FileDialog.filename)
    FileDialog.InitDir = Left$(fname, Len(fname) _
        - Len(FileDialog.FileTitle) - 1)
    Caption = "PalDraw [" & fname & "]"

    ' Load the picture.
    Canvas.Picture = LoadPicture(fname)
    ResetSwatches
    Exit Sub

LoadError:
    Beep
    MsgBox "Error loading picture " & fname & _
        "." & vbCrLf & Error$, vbExclamation
End Sub

Private Sub ObjectCombo_Click()
    Obj = ObjectCombo.ListIndex
End Sub


' ***********************************************
' Change set DrawWidth.
' ***********************************************
Private Sub WidthText_Change()
Dim wid As Integer

    If Not IsNumeric(WidthText.Text) Then Exit Sub

    wid = CInt(WidthText.Text)
    If wid < 1 Then Exit Sub

    Canvas.DrawWidth = wid
End Sub

' ***********************************************
' Only allow 1 through 9.
' ***********************************************
Private Sub WidthText_KeyPress(KeyAscii As Integer)
    If KeyAscii < Asc(" ") Or _
       KeyAscii > Asc("~") Then Exit Sub
    If KeyAscii >= Asc("1") And _
       KeyAscii <= Asc("9") Then Exit Sub
    Beep
    KeyAscii = 0
End Sub